Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/bmplbo/bmplbox.pas

Pascal/Delphi Source File | 1995-12-22 | 15.8 KB | 475 lines

unit Bmplbox;

{
  TBmpListBox & TBmpComboBox components
  *************************************

  Freeware by MainSoft sarl.
  Uploaded by Patrick Philippot, CIS: 72561,3532

  This unit contains two components implementing an owner-draw Listbox and
  an owner-draw combobox that are able to display a bitmap (glyph) along
  with the item string. They work exactly the same way, so we'll explain
  TBmpListBox only. As you'll see, the code for both component is
  identical, so there's room for optimization by sharing a few routines.
  We didn't make this choice because sharing routines implied passing
  a great number of parameters which would have made the code unclear.
  So, we have merely duplicated the code.

  This is a "let's see what we can do with Delphi" package. We may have
  missed some possibilities of optimizing the code. Feel free to enhance
  it and to re-upload. Although the code is rather simple and significantly
  shorter than its BP7 and VC++ counterparts, it took more time to develop,
  due to the lack of a good documentation. In our opinion, Delphi deserves
  a better documentation.

  This code is based on information found in TI2793.ASC (a technical note
  from Borland). However, it takes a more sophisticated approach.

  The two components have the xxOwnerDrawVariable style which was actually
  not necessary but for an unknown reason, the MeasureItem method is not
  called when we use the xxOwnerDrawFixed style (in that case, the
  WM_MEASUREITEM message is sent only once but it is sent). Since we do
  not have received the VCL source code yet, we can't tell you whether it's
  a bug in the library.

  *********************

  TBmpListBox derives from TListBox and adds the capability of displaying
  a bitmap on the left of the item string. Each item in the listbox can have
  a different bitmap (glyph). Both the bitmap and the text string are
  automatically centered vertically. So they can be of any height (within a
  reasonable range).

  In order to limit system resource consumption, TBmpListBox assumes that
  all glyphs are contained within a single bitmap strip and that they all have
  the same width. This way, each glyph can be indexed. The bitmap strip is a
  property of TBmpListBox and is initially empty.

  The index of the glyph associated with a particular listbox item is stored
  in the HiWord of Items.Object[item_index]. The LoWord can be used by the
  application. The best way to make this association is to use the AddObject
  method and to do some typecasting. See sample program.

  This approach has a drawback regarding the general philosophy of developing
  Delphi Components. Since there's no way for TBmpListBox to determine the
  width of a single glyph in the bitmap strip, no bitmap will be displayed
  until the user defines a positive value for the BmpItemWidth property.
  Also, there is no "default bitmap".

  If no TBitmap has been assigned to BitmapStrip or if BmpItemWidth is null or
  if the assigned bitmap is empty, TBmpListBox will behave as a standard
  listbox.

  New properties:
  _______________

  All these properties can be changed dynamically at run time (although
  this will happen very rarely).


  BitmapStrip         A TBitmap that must be supplied by the application.
             BitmapStrip defaults to nil (none).

             Once you have assigned a TBitmap to BitmapStrip, you
             can Destroy the source bitmap. SetBitmapStrip uses the
             Assign method to copy the bitmap data.

  BmpItemWidth         The width, in pixels, of one single glyph in the bitmap
             strip. Both BitmapStrip and BmpItemWidth must be valid
             in order to display an associated bitmap with each item.
             BmpItemWidth defaults to 0.

  Leftmargin         The space in pixels left between the left side of the
             listbox and the left side of the glyph AND between the
             right side of the glyph and the beginning of the text
             string. This value is ignored if BmpItemWidth and/or
             BitmapStrip are not valid. Leftmargin defaults to 4.

  TopAndBottomMargin The additional space in pixels left at the bottom AND
             at the top of the item rectangle. TopAndBottomMargin
             defaults to 3.

  TransparentColor   This TColor defines which color in the glyph will be
             made transparent when displaying the glyph on the
             item's rectangle background. TransparentColor defaults
             to clGray.

  *********************

  You are granted the right to use and peruse this code in your applications
  without notifying MainSoft. However, this code can't be published without
  written permission of MainSoft.

  Have fun!


  A few words about MainSoft:
  ***************************

  MainSoft sarl is a french company created by Patrick Philippot, a
  former IBM engineer. MainSoft specializes in training (VB, VC++,
  OLE2, ODBC, ...), consulting and development for Windows and Windows
  NT. We also have a good experience in software localization. Our
  flagship product is a shareware programming editor: E! for Windows.

  E! is the most powerful shareware editor available. Syntax Highlighting
  for any language (user configurable), function tagging and many other
  original features make this product unique. It is as powerful as (or even
  more powerful than) many shrink-wrapped text editors but at a fraction of
  the price.

 *************************************************************************
  As it supports the Borland Pascal compiler, E! also fully supports the
  Delphi command line compiler. You can transparently compile and jump to
  the syntax errors in the source file without even seeing DCC.EXE running.
 *************************************************************************

  You can download E! from many Compuserve libraries (PCAPP, WINSHARE,
  WINSDK, WUGNET,...). Look for EWARC2.EXE. Available patches are
  always uploaded as EWPxxx.ZIP.

  Feel free to drop a message to Patrick Philippot [72561,3532] if you
  need any information.

     MainSoft sarl
     15, avenue des Pres Pierre
     91210 Draveil
     France
     tel/fax: [phone]
     CIS: 72561,3532
     INTERNET: [e-mail]

  Currently, the distribution of E! is managed in the USA and Canada by

       HomeBrew Software
       807 Davis Street
       Suite E
       Vacaville, CA 95687
       [phone]  Voice
       [phone]  FAX

  and by Juergen Egeling Computer (for other countries with exception
  of France)

       Juergen Egeling Computer
       Werderstr. 41, 76137 Karlsruhe, Germany.
       Tel: [phone] / Fax: [phone]
       email: [e-mail]


  Draveil, France, 06-07-95
}

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

type

  TBmpListBox = class(TListBox)
  private
    { Private declarations }
    FBitmapStrip    : TBitmap;
    FBmpItemWidth    : integer;
    FLeftMargin     : integer;
    FTopAndBottomMargin : integer;
    FTransparentColor    : TColor;
    bOkToDraw        : boolean;
    yBmpOffset        : integer;

  protected
    { Protected declarations }
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure MeasureItem(Index: Integer; var Height: Integer); override;

  public
    { Public declarations }
    constructor Create(AOwner : TComponent); override;
    destructor    Destroy; override;
    procedure    SetBitmapStrip(ABitmapStrip : TBitmap);
    procedure    SetBmpItemWidth(NewWidth : integer);
    procedure    SetLeftMargin(NewMargin : integer);
    procedure    SetTopAndBottomMargin(NewMargin : integer);
    procedure    SetTransparentColor(NewColor : TColor);
    procedure    CheckContext;

  published
    { Published declarations }
    property BitmapStrip : TBitmap read FBitmapStrip write SetBitmapStrip;
    property BmpItemWidth : integer read FBmpItemWidth write SetBmpItemWidth default 0;
    property LeftMargin : integer read FLeftMargin write SetLeftMargin default 4;
    property TopAndBottomMargin : integer read FTopAndBottomMargin write SetTopAndBottomMargin default 3;
    property TransparentColor : TColor read FTransparentColor write SetTransparentColor default clGray;
  end;

  TBmpComboBox = class(TComboBox)
  private
    { Private declarations }
    FBitmapStrip    : TBitmap;
    FBmpItemWidth    : integer;
    FLeftMargin     : integer;
    FTopAndBottomMargin : integer;
    FTransparentColor    : TColor;
    bOkToDraw        : boolean;
    yBmpOffset        : integer;

  protected
    { Protected declarations }
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    procedure MeasureItem(Index: Integer; var Height: Integer); override;

  public
    { Public declarations }
    constructor Create(AOwner : TComponent); override;
    destructor    Destroy; override;
    procedure    SetBitmapStrip(ABitmapStrip : TBitmap);
    procedure    SetBmpItemWidth(NewWidth : integer);
    procedure    SetLeftMargin(NewMargin : integer);
    procedure    SetTopAndBottomMargin(NewMargin : integer);
    procedure    SetTransparentColor(NewColor : TColor);
    procedure    CheckContext;

  published
    { Published declarations }
    property BitmapStrip : TBitmap read FBitmapStrip write SetBitmapStrip;
    property BmpItemWidth : integer read FBmpItemWidth write SetBmpItemWidth default 0;
    property LeftMargin : integer read FLeftMargin write SetLeftMargin default 4;
    property TopAndBottomMargin : integer read FTopAndBottomMargin write SetTopAndBottomMargin default 3;
    property TransparentColor : TColor read FTransparentColor write SetTransparentColor default clGray;
  end;

procedure Register;


implementation


{-TBmpListBox}

constructor TBmpListBox.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FBitmapStrip := TBitmap.Create;
  FBmpItemWidth := 0;
  yBmpOffset := 0;
  FLeftMargin := 4;
  FTopAndBottomMargin := 3;
  FTransparentColor := clGray;
  Style := lbOwnerDrawVariable;

  {-We should be able to use the lbOwnerDrawFixed style but, strangely
   enough, MeasureItem is never called in that case. Normally, when the
   lbOwnerDrawFixed style is used, the WM_MEASUREITEM message is
   sent once and only once. Since I don't have received the VCL source
   code yet, I cannot explain this behavior but it looks like a bug.}

  bOkToDraw := false;
end;

destructor TBmpListBox.Destroy;
begin
  if Assigned(FBitmapStrip) then
    FBitmapStrip.Destroy;
  inherited Destroy;
end;

procedure TBmpListBox.CheckContext;
begin
 {-Verify that critical properties have been correctly setup}
  bOkToDraw := (FBmpItemWidth > 0) and Assigned(FBitmapStrip) and not FBitmapStrip.Empty;
end;

procedure TBmpListBox.SetBitmapStrip(ABitmapStrip : TBitmap);
begin
 {-Copy data from source bitmap}
  FBitmapStrip.Assign(ABitmapStrip);
  CheckContext;
  Invalidate;
end;

procedure TBmpListBox.SetBmpItemWidth(NewWidth : integer);
begin
  FBmpItemWidth := NewWidth;
  CheckContext;
  Invalidate;
end;

procedure TBmpListBox.SetLeftMargin(NewMargin : integer);
begin
  FLeftMargin := NewMargin;
  Invalidate;
end;

procedure TBmpListBox.SetTransparentColor(NewColor : TColor);
begin
  FTransparentColor := NewColor;
  Invalidate;
end;

procedure TBmpListBox.SetTopAndBottomMargin(NewMargin : integer);
begin
  FTopAndBottomMargin := NewMargin;
  Invalidate;
end;

procedure TBmpListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  OutStr   : PChar;
  len       : word;
begin
  with Canvas do begin
    FillRect(Rect);
   {-Check critical properties and validity of glyph index}
    if bOkToDraw and ((BmpItemWidth * HiWord(longint(Items.Objects[Index]))) < FBitmapStrip.Width) then
      BrushCopy(Bounds(Rect.left + FLeftMargin,
               Rect.top + yBmpOffset,
               FBmpItemWidth,
               FBitmapStrip.Height),
        FBitmapStrip,
        Bounds(BmpItemWidth * HiWord(longint(Items.Objects[Index])),
               0,
               FBmpItemWidth,
               FBitmapStrip.Height),
        FTransparentColor);
   {-If we're not "OKToDraw", the LeftMargin property is ignored}
   {-We use the DrawText API which is more accurate than Canvas.TextOut}
    Rect.left := Rect.left + BmpItemWidth + (FLeftMargin * 2 * Ord(bOkToDraw));
    len := Length(Items[index]);
    GetMem(OutStr, len + 1);
    StrPCopy(OutStr, Items[index]);
    DrawText(Handle, OutStr, len, Rect, dt_Left or dt_VCenter or dt_SingleLine);
    FreeMem(OutStr, len + 1);
  end;
end;

procedure TBmpListBox.MeasureItem(Index: Integer; var Height: Integer);
var
  TxtHeight : integer;
begin
  if bOkToDraw then begin
    TxtHeight := Abs(Font.Height);
   {- When we receive the WM_MEASUREITEM message, the font used for the
     Control has not been yet determined by Windows. Using Canvas.TextHeight
     would return a wrong value. So, we MUST use the Font property to
     retrieve the font height.}
    if TxtHeight > FBitmapStrip.Height then
      Height := TxtHeight
    else
      Height := FBitmapStrip.Height;
    Inc(Height, FTopAndBottomMargin * 2);
    yBmpOffset := (Height - FBitmapStrip.Height) div 2;
  end;
end;


{-TBmpComboBox - Identical to TBmpListBox}

constructor TBmpComboBox.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FBitmapStrip := TBitmap.Create;
  FBmpItemWidth := 0;
  yBmpOffset := 0;
  FLeftMargin := 4;
  FTopAndBottomMargin := 3;
  FTransparentColor := clGray;
  Style := csOwnerDrawVariable;
  bOkToDraw := false;
end;

destructor TBmpComboBox.Destroy;
begin
  if Assigned(FBitmapStrip) then
    FBitmapStrip.Destroy;
  inherited Destroy;
end;

procedure TBmpComboBox.CheckContext;
begin
  bOkToDraw := (FBmpItemWidth > 0) and Assigned(FBitmapStrip) and not FBitmapStrip.Empty;
end;

procedure TBmpComboBox.SetBitmapStrip(ABitmapStrip : TBitmap);
begin
  FBitmapStrip.Assign(ABitmapStrip);
  CheckContext;
end;

procedure TBmpComboBox.SetBmpItemWidth(NewWidth : integer);
begin
  FBmpItemWidth := NewWidth;
  CheckContext;
end;

procedure TBmpComboBox.SetLeftMargin(NewMargin : integer);
begin
  FLeftMargin := NewMargin;
  Invalidate;
end;

procedure TBmpComboBox.SetTransparentColor(NewColor : TColor);
begin
  FTransparentColor := NewColor;
  Invalidate;
end;

procedure TBmpComboBox.SetTopAndBottomMargin(NewMargin : integer);
begin
  FTopAndBottomMargin := NewMargin;
  Invalidate;
end;

procedure TBmpComboBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  OutStr   : PChar;
  len       : word;
begin
  with Canvas do begin
    FillRect(Rect);
    if bOkToDraw and ((BmpItemWidth * HiWord(longint(Items.Objects[Index]))) < FBitmapStrip.Width) then
      BrushCopy(Bounds(Rect.Left + FLeftMargin,
               Rect.Top + yBmpOffset,
               FBmpItemWidth,
               FBitmapStrip.Height),
        FBitmapStrip,
        Bounds(BmpItemWidth * HiWord(longint(Items.Objects[Index])),
               0,
               FBmpItemWidth,
               FBitmapStrip.Height),
        FTransparentColor);
    Rect.left := Rect.left + BmpItemWidth + (FLeftMargin * 2 * Ord(bOkToDraw));
    len := Length(Items[index]);
    GetMem(OutStr, len + 1);
    StrPCopy(OutStr, Items[index]);
    DrawText(Handle, OutStr, len, Rect, dt_Left or dt_VCenter or dt_SingleLine);
    FreeMem(OutStr, len + 1);
  end;
end;

procedure TBmpComboBox.MeasureItem(Index: Integer; var Height: Integer);
var
  TxtHeight : integer;
begin
  if bOkToDraw then begin
    TxtHeight := Abs(Font.Height);
    if TxtHeight > FBitmapStrip.Height then
      Height := TxtHeight
    else
      Height := FBitmapStrip.Height;
    Inc(Height, FTopAndBottomMargin * 2);
    yBmpOffset := (Height - FBitmapStrip.Height) div 2;
  end;
end;


{-register both components}
procedure Register;
begin
  RegisterComponents('Additional', [TBmpListBox, TBmpComboBox]);
end;

end.